perm filename BEAMS.F4[1,LCS]2 blob
sn#678470 filedate 1982-09-17 generic text, type T, neo UTF8
C**** BEAMS.F4 ****
COPYRIGHT 1982 BY LELAND SMITH
C*** BEAMS, BMREAD, NREST ************
SUBROUTINE BEAMS
INTEGER UPDN
COMMON R2,JAZ,CENTR,JBZ,RJQ(20),JQ(20) /STF/RSTFAC(8),RSTJ2
1 /XRN/RN(1) /PTR/KWDS(1) /RNW/RNW /A2Z/LAA,LBB
1 /RINP/R(10,85),POSNT(0/99) /RMOD/RMODE2,SET4,IBEAM,
1 NOSET,STEM,STUP,NTC,PS2,RAM,JSTEM,IT,POS
1 /FRMT/F78F(1),FA1(1),FA5(1) /ALF/INP(72),ML
1 /LIMIT/LIMIT,ITEM,LL,IS,IX /DPY/ST(3900),RHY(100)
1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
1 /SCX/JALPHA(7),ISTAR,JAL(22),X,U,JZ,IRHY,JD,KA,KB,IZ
1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
1 ,JXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
IF(RMODE.GE.500)RETURN
C NO BEAMS WHEN USING SUBR. 'EXTRA' *********
INVT=-1
LS=IS
C SAVE PTR TO RN ARRAY FOR SLUR FEATURE AT 614 (AND TREM. FEATURE)
JNTC=NTC
J=0
A=-1.
DO 1125 K=1,IZ
RHY(K)=0
C MUST BE ZEROED TO AVOID CONFUSION AT C.2212
IF(R(1,K).GT.2)GO TO 1125
C GET BACK RHYTH. INFO IN P9 OF NOTES (FOR JDIF, COMPOSITE BEAMS)
B=R(3,K)
IF(A.EQ.B)GO TO 1125
C SKIP CHORD NOTES.
A=B
J=J+1
RHY(K)=V(J)
1125 CONTINUE
125 IF(REND.NE.0)GO TO 25
REND=3
25 DO 1500 K=1,72
IF(INP(K).EQ.LBB)GO TO 22
C B=AUTOMATIC BEAMS.
IF(INP(K).EQ.ISTAR)GO TO 15
1500 IF(INP(K).EQ.ISEMI)GO TO 500
15 INP(72)=ISTAR
GO TO 500
C ABOVE FOR 2ND LNE OF INPUT. IF LNS ENDS WITHOUT * OR ;, IT PUTS IN *
C*** 9/82 22 REREAD F78F,A,RB
C*** A=A/2.
C TYPE '2B' OR '3B' ETC. FOR AUTOMATIC BEAMS. (2=DUPLE 3=TRIPLE)
22 CALL RREAD(INP,VX)
A=VX(1)/2.
RB=VX(2)
C '2'=1 '3'=1.5 '2B 3;' MEANS THERE'S A 3 NOTE PICK-UP.
CS IF(STEM)STEM=0
C STEM=10 OR 20 IF ALREADY SETUP IN NOTES
N=0
J=0
INP(72)=ISTAR
GR=4./88.
NN=0
NX=0
C NX IS REST COUNTER
NZ=0
NL=1
NJ=0
NR=1
JV=0
C JV IS VX COUNTER
C=0
B=A-.001
IF(RB.EQ.0)GO TO 122
J=RB
C RB=NUM OF PICKUP ITEMS.*******(NTS AND RSTS - BUT NOT GRACE NTS.)*******
B=-.001
DO 222 K=1,J
222 IF(V(K).NE.GR)B=B+ABS(V(K))
C ABOVE FOUND VALUE OF PICKUPS
122 X=ABS(V(NR))
IF(X.NE.GR)GO TO 2122
NN=NN+1
GO TO 2022
2122 C=C+X
C ADD ON RHYTH VALUE -- IF NOT GRACE NOTES
IF(V(NR).LT.0)N=N+1
C FINDS RESTS AND GRACE NOTES (WE SKIP THEM)
IF(C.GT.B)GO TO 822
2022 IF(NR.EQ.IRHY)GO TO 422
922 NR=NR+1
CC IF(NOTAIL(V(NR-1)).LT.0)GO TO 322
C NR=RIGHT SIDE OF BEAM, NL=LEFT
GO TO 122
822 IF(NR-NL-NN-N.GT.0)GO TO 322
C IGNORE IF ONLY ONE NOTE FILLS UNIT
722 IF(NR.EQ.IRHY)GO TO 422
NN=0
NJ=NJ+N
NZ=NJ
N=0
NL=NR+1
C PUSH AHEAD FOR NEXT BEAM
622 B=B+A
C UPDATE SPACE POINTER
IF(C.GT.B)GO TO 622
GO TO 922
C MAIN AUTO BEAM SECTION.
322 DO 21 K=NL,NR-1
C THIS LOOP FINDS FIRST NOTE OF BEAM.
X=V(K)
IF(X.LT.0)GO TO 21
IF(X.EQ.GR)GO TO 21
IF(NOTAIL(X).LT.0)GO TO 21
C SKIP IF NOTE VAL. DOESN'T REQUIRE A TAIL
COUNTER FOR VX ARRAY (WHERE WE PUT BEAM'S NOTE NUMS.)
VX(JV+1)=K-NREST(K)
C FUNCT. NREST TELLS HOW MANY RESTS TO SUBTRACT
GO TO 221
21 CONTINUE
C IF WE GET HERE, NO BEAM NOTES FOUND.
GO TO 722
221 DO 321 JB=K,NR
C THIS LOOP FINDS LAST NOTE OF BEAM.
X=V(JB)
IF(NOTAIL(X).LT.0)GO TO 522
C JUMP OUT WHEN NON-BEAM DURATION IS FOUND
IF(X.LT.0)GO TO 321
IF(X.EQ.GR)GO TO 321
JA=JB
321 CONTINUE
522 IF(JA.EQ.K)GO TO 523
JV=JV+2
VX(JV)=JA-NREST(JA)
C NREST SUBTRACTS ALL INTERVENING RESTS
523 IF(JA.GE.NR-1)GO TO 722
C NO ROOM FOR MORE BEAMS
NL=JB
C START FROM WHERE WE LEFT OFF
GO TO 322
C NEXT FOR BEAMED GRACE NOTES
422 N=0
J=1
1122 X=V(J)
IF(X.LT.0)N=N+1
NR=0
IF(X.NE.GR)GO TO 1022
NL=J
DO 1222 K=J,IRHY
X=V(K)
IF(X.LT.0.OR.X.NE.GR)GO TO 1322
C STOPS GRACE NOTE BEAM AT REST OR NON-GRACE
1222 NR=K
1322 IF(NR-NL.LE.0)GO TO 1022
CALL BAUTO(JV,NL,NR,N)
C UPDATE VX COUNTER
NL=NL+1
J=NR
1022 J=J+1
IF(J.LE.IRHY)GO TO 1122
1422 IF(JV.EQ.0)RETURN
C NO BEAMS - SO GO BACK.
DO 2822 K=JV+1,50
C USES ONLY 68 SLOTS IN 'V'
2822 VX(K)=0
CC END
J=0
GO TO 511
C ******* 1ST MAIN LOOP *********
C*** 9/82 500 REREAD F78F,VX
500 CALL RREAD(INP,VX)
J=0
511 J=J+1
N=VX(J)
JMP=1
JDIF=0
505 L=0
K=0
C=0
POS=-10.
RN(8+IS)=0
RN(9+IS)=0
IT=0
UPDN=0
C UPDN=NEG.=STEMS DOWN, POS.=STEMS UP
104 JA=J+1
B=VX(JA)
C THE 2ND NOTE (-=STEM DOWN ALWAYS; +100=UP ALWAYS, ORD.=AUTOMATIC)
IF(B.LT.0)B=200.-B
IF(B.LT.100)GO TO 512
B=B-100
IF(B.GT.100)B=100-B
C TYPE -NUM OR 200+NUM FOR DIP DOWN.
VX(JA)=B
UPDN=B
C***512 IF(B.LT.0)UPDN=1
512 RN(9+IS)=0
BRK=AMOD(VX(J),1.)*10.
IF(BRK.NE.0)RN(9+IS)=BRK+.0001
C ADDS NUM TO BRACK. OR BEAM. ADD DESIRED .NUM TO 1ST NUM.(1.3=3)
503 IF(N.LE.0.OR.N.GE.JNTC)TYPE 5031,N
5031 FORMAT(' ****WRONG BEAM NUMBER? ',I3)
5030 L=L+1
502 K=K+1
IF(R(1,K).NE.1.)GO TO 502
C IS IT A NOTE?
P=R(3,K)
IF(P.EQ.POS)GO TO 502
C SKIPS DBLSTPS
POS=P
IF(L.LT.N)GO TO 506
IF(C.NE.0)GO TO 506
IF(R(10,K).EQ.0)C=19.-R(5,K)
C GET STEM DIR. OF 1ST NOTE ON MAIN STAFF
506 IF(L.LT.N)GO TO 5030
5060 IF(JMP.LT.0)GO TO 504
C JMP=-1 MEANS END NOTE OF GROUP
J=J+1
NN=VX(J)
C IF 2ND NUM IS .LE. 1ST , THEN 2-NOTE SLUR. (-1 GOES TO 1)
IF(NN.EQ.0)NN=N+1
IF(NN.EQ.0)NN=1
IF(NN.LT.0)GO TO 5061
IF(NN.LE.N)NN=N+1
C FOR USE WITH AUTO-BEAMS OR DIP UP. 2-NOTE SLUR OR BEAM UP.
5061 MK=N
N=IABS(NN)
M=K
JA=3
JB=4
KN=K
RB=0
GO TO 550
504 RB=2
IF(NN.LT.0)RB=-RB
C STEM DIRECT. IS SET BY PARAM 7. (STEM DIR. IS AUTOMATIC)
550 RN(JA+IS)=POS
B=ZNOTE(K)
C ZNOTE GETS HEIGHT AND CHECKS FOR NOTE ON OTHER STAFF/STEM DIR.
513 RN(JB+IS)=B+RB
C MK=# OF 1ST NOTE, N=END NOTE NOW
JMP=-JMP
IF(JMP.GT.0)GO TO 1503
C GO FIND RT. SIDE OF SLUR
JA=6
JB=5
IF(N.LE.MK)N=MK+1
C PICKS UP TYPO ERRORS
GO TO 503
1503 RN(2+IS)=STAFF
IF(NN.GE.0)GO TO 277
IF(C.GT.0)GO TO 377
277 IF(C.GE.0)GO TO 35
IF(NN.LE.0)GO TO 35
377 NN=-NN
C RA WILL=# OF TAILS, KN=1ST NOTE, K=LAST ('MOD' FOR DOTTED NOTES.)
35 RN(1+IS)=6
JMAX=0
IF(N-MK.EQ.1)JMAX=-1
DMAX=100.
UMAX=-DMAX
C FOR AUTO. BEAMS
JB=0
MB=0
C MB=-1 =GRACE NOTES UNDER BEAMS.
IF(ABS(R(4,KN)).GE.80.)MB=-1
RDIF=0
C JDIF AND RDIF ARE FOR NEW COMPOSITE BEAM FEATURE 5/78
JDIF=0
DO 2 L=KN,K
IF(R(1,L).NE.1)GO TO 2
IF(JDIF.NE.0)GO TO 1212
BB=RHY(L)
IF(BB.LE.0)GO TO 1212
IF(BB.EQ.4./88.)GO TO 1212
IF(RDIF.NE.0)GO TO 2212
RDIF=BB
C NOW WE HAVE FIRST RHYTH. VALUE UNDER BEAM
RA=AMOD(R(7,L),10.0)
C RA WILL=# OF TAILS ON 1ST NOTE.
GO TO 1212
2212 IF(RDIF.EQ.BB)GO TO 1212
JDIF=L
KDIF=IS
C FOUND A DIFF. RHYTH. UNDER BEAM
CXCX1212 IF(R(10,L).NE.0)GO TO 2
C SKIP NOTES ON ANOTHER STAFF.**************?????????????
1212 BB=R(5,L)
IF(BB.GE.10.)GO TO 12
UPDN=-1
NN=19-AA
CHORDS WILL HAVE FIXED STEM DIRECTIONS ALWAYS
GO TO αm
C SKIPS NON-NOTES AND DBLSTPS
12 IF(MB.LT.0)GO TO 10
AA=BB
RB=R(4,L)
IF(ABS(RB).GE.80)GO TO 2
C SKIPS GRACE NOTES
GO TO 110
10 RB=ZNOTE(L)
110 IF(RB.GT.UMAX)UMAX=RB
IF(RB.LT.DMAX)DMAX=RB
C FOR AUTO. BEAMS
RB=AMOD(R(7,L),10.0)
112 IF(RA.EQ.RB)GO TO 2
JB=-1
C FLAG FOR MIXED NUM. OF BEAMS
IF(RB.GE.RA)GO TO 2
IF(RB.NE.0)RA=RB
2 CONTINUE
C ABOVE FINDS SMALLEST # OF TAILS. NEXT FOR HGTS.
C ABOVE IS POS.2
IT=KN
M=3
203 IF(R(10,IT).EQ.0)GO TO 202
IF(JSTEM.GT.IT)GO TO 202
CS IF(STEM.LE.0)GO TO 202
C=RNW
IF(NN.LT.0)GO TO 206
IF(R(5,IT).LT.20)GO TO 202
C=-C
GO TO 205
206 IF(R(5,IT).GE.20)GO TO 202
205 IF(ABS(R(4,IT)).GE.80.)C=C*.6
C FOR MINI BEAMS
RN(M+IS)=RN(M+IS)+C*RSTJ2
202 IF(IT.NE.KN)GO TO 201
IT=K
M=6
GO TO 203
C FOR EXTRA BEAMS WITH CHORDS. SAVE IT IN "IT"
201 IF(JSTEM.LE.IT)GO TO 577
CS201 IF(STEM.GT.0)GO TO 577
C *****↑↑↑↑↑↑ ABOVE WAS ".NE." BEFORE 4/30/76. WHY?#@&Xαε
C*** IF(UPDN.NE.0)GO TO 577
IF(UPDN.EQ.-1)GO TO 577
NN=-1
IF(UMAX+DMAX.LT.14)NN=-NN
C SETS AUTO. BEAMS' STEM DIRECTION.
IF(UPDN.NE.0)NN=UPDN
577 X=10
IF(NN.LT.0)X=20
IF(MB.LT.0)RA=2
C 2 BEAMS ON GRACE NOTES ALWAYS
X=X+RA
C # OF BEAMS. IT'S PUT IN DOWN BELOW 550.
200 M=KN
207 L=M+1
IF(R(1,L).NE.1)GO TO 307
IF(R(5,L).GE.10)GO TO 307
M=M+1
GO TO 207
C FOR HEIGHTS OF DBL STPS, ETC.
307 CONTINUE
607 A=ZNOTE(M)
C A=NOTE 1.
UMAX=A
DMAX=A
C UP MAX. NOTE #, DOWN MAX. NOTE #.
407 M=K+1
IF(R(1,M).NE.1)GO TO 603
CC IF(R(9,M).NE.0)GO TO 603
IF(R(5,M).GE.10)GO TO 603
C FINDS DBL+ STP ON LAST OF BEAM
IF(R(6,M))GO TO 603
C JUMP OUT IF A WHITE NOTE
K=M
GO TO 407
CXX 103 IF(JSTEM.GT.KN)GO TO 604
C FLAG IS SET (NR) IF STEMS ARE SPECIFIED IN DIFF. DIRECTIONS. (GRACE NTS??)
CXX 604 NR=0
603 DO 3 M=KN,K
IF(R(1,M).NE.1)GO TO 3
CXCXCX IF(STEM.NE.0.AND.R(10,M).NE.0)GO TO 3
C SKIP NOTES ON OTHER STAFF
IF(M.EQ.K)GO TO 107
IF(R(1,M+1).NE.1)GO TO 107
C IT ONLY CARES ABOUT NOTES!
IF(R(5,M+1).LT.10)GO TO 3
C IGNORE LOWER (OR UPPER) NOTES OF CHORDS (NO STEM)-IN RE. UP-DOWN FEATURE.
107 IF(MB.LT.0)GO TO 7
C SKIP IF DEALING WITH GRACE NOTE BEAMS. (MB=-1)
IF(ABS(R(4,M)).GE.100)GO TO 3
C SKIPS NON-NOTES
7 B=ZNOTE(M)
677 IF(JSTEM.LE.KN)GO TO 55
C IGNORE STEM DIR. IF ALREADY SPECIFIED WITHIN THIS GROUP
AA=R(5,M)
IF(AA.LT.10.)GO TO 551
STMDR=AA
IF(NN.GT.0)GO TO 5
C JUMP IF STEM UP
IF(STMDR.GE.20.)GO TO 55
IF(STMDR.LT.10.)GO TO 55
R(5,M)=STMDR+10.
GO TO 551
5 IF(STMDR.LT.20.)GO TO 55
R(5,M)=STMDR-10.
C************************
C STEM UP
551 INVT=0
55 IF(B.LT.UMAX)GO TO 13
CC55 IF(B.LE.UMAX)GO TO 13
C ↑↑↑↑↑↑↑↑ WAS .LT. !!!!! 5/76
UMAX=B
IF(JMAX.LT.0)GO TO 3
IF(M.EQ.KN)GO TO 3
IF(M.EQ.K)GO TO 3
UMAX=UMAX+1
GO TO 3
13 IF(B.GT.DMAX)GO TO 3
DMAX=B
IF(JMAX.LT.0)GO TO 3
IF(M.EQ.KN)GO TO 3
IF(M.NE.K)DMAX=DMAX-1
3 CONTINUE
C LOOKS FOR LOWER AND HIGHER NOTES THAN NOTE 1.
C*************************************
4 K=IT
C FOR EXTRA BEAMS WITH CHORDS. K WAS SAVED IN "IT"
AA=A
BB=B
C=1
IF(X.LT.20.)GO TO 48
C JUMP IF STEM IS UP
CC CALL EXCH(AA,BB)
AA=UMAX
UMAX=DMAX
DMAX=AA
AA=BB
BB=A
C=-C
CC CALL EXCH(UMAX,DMAX)
48 IF(AA.LT.BB)GO TO 45
IF(UMAX.EQ.A)GO TO 46
47 A=UMAX-C
B=A
GO TO 444
46 IF(UMAX.GT.AA)GO TO 47
GO TO 49
45 IF(UMAX.NE.B)GO TO 47
49 A=AA
B=BB
IF(X.LT.20)GO TO 444
CC CALL EXCH(A,B)
A=B
B=AA
444 RN(2+IS)=STAFF
446 DIS=(RN(IS+6)-RN(IS+3))/6.
C FOR TILT LATER --
IF(ABS(A-B).LT.DIS)GO TO 143
C=C*DIS
C NEW TILT ROUTINE. CONSIDERS DISTANCE:HEIGHT
C LIMITS SLOPE OF BEAM
IF(X.GE.20)GO TO 141
IF(B.GT.A)GO TO 140
142 B=A-C
GO TO 143
141 IF(B.GT.A)GO TO 142
140 A=B-C
143 JA=KN+1
IF(R(1,JA).NE.1.OR.R(5,JA).GE.10)GO TO 144
M=K+1
IF(R(1,M).NE.1.OR.R(5,M).GE.10)GO TO 144
IF(R(4,JA).EQ.R(4,M).AND.R(4,KN).EQ.R(4,K))B=A
C MAKE BEAM LEVEL IF SAME DYAD AT START AND END.
144 IF(X.GE.20)GO TO 530
C BEAM WILL ALWAYS TOUCH MIDDLE LINE OF STAFF
IF(A.LT.0)A=0
IF(B.LT.0)B=0
GO TO 14
530 IF(A.GT.14)A=14
IF(B.GT.14)B=14
C GETS NEW HEIGHT NUMBERS.
14 IF(MB.EQ.0)GO TO 330
C NEXT FOR GRACE NOTE BEAMS (MB=-1)
C=100
IF(A.LT.0)C=-C
A=A+C
330 C=AMOD(X,10.0)-2
IF(C.LE.0)GO TO 331
C NEXT PUSHES OUT BEAMS IF 3 OR MORE.
C=C+1
IF(NN.LT.0)C=-C
A=A+C
B=B+C
331 RN(4+IS)=A
RN(5+IS)=B
C MAKES HORIZONTAL BEAMS IF PATTERN IS UP-DOWN.
C*******?????? RN(6+IS)=R(3,K)
C ABOVE IS POS.2
C NEXT TO FIND TREMOLOS WHICH SHOULD BE PARALLEL TO BEAM.
JA=IX
AA=RN(IS+3)
BB=RN(IS+6)
300 IF(JA.GE.LS)GO TO 510
C LS IS PTR TO RN ARRAY BEFORE BEAMS WERE ADDED.
IF(RN(JA+1).EQ.6)GO TO 1300
2300 JA=RN(JA)+JA+3
C PUSH PTR AHEAD
GO TO 300
1300 C=RN(JA+3)
IF(C.LT.AA.OR.C.GT.BB)GOTO 2300
C NOW WE'VE FOUND TREM. WITHIN RANGE OF CURRENT BEAM.
RN(JA+9)=C
RN(JA+3)=AA
RN(JA+6)=BB
RN(JA+4)=A
RN(JA+5)=B
C=RN(JA+7)
IF(C.GT.-20.)GO TO 3300
IF(X.LT.20.)C=C+10
GO TO 4300
3300 IF(X.GE.20)C=C-10
4300 RN(JA+7)=C
C X=P7 INFO FOR CURRENT BEAM. (STEM DIR., NUM. OF BEAMS.)
RN(JA+10)=ABS(AMOD(X,10.0))
GO TO 2300
C ***********KN = 1ST NOTE, K=LAST NOTE.********
510 M=R(5,KN)/10.0
RN(7+IS)=M*10+AMOD(X,10.0)
RN(10+IS)=0
RN(IS+11)=-1
CALL UPDATE(9)
JA=IS
C************************************** BMX ***********
IF(JB.LT.0)CALL BMX(RA)
IF(JA.NE.IS)GO TO 514
IF(JDIF.EQ.0)GO TO 514
C FOR NEW COMPOSITE BEAM FEATURE 4/78
IF(RA.EQ.1)GO TO 514
RN(7+KDIF)=X-1
RN(10+KDIF)=100
DO 515 K=JDIF-1,1,-1
C LOOK FOR INTERVENING GRACE NOTES OR RESTS.
N=K
IF(R(1,K).NE.1)GO TO 515
IF(R(8,K).EQ.1000.)GO TO 515
N=K
GO TO 516
515 CONTINUE
516 RN(8+KDIF)=R(3,N)
RN(9+KDIF)=R(3,JDIF)
A=R(3,N)
B=R(3,JDIF)
IF(A.EQ.RN(3+KDIF))A=A+2.4
IF(B.EQ.RN(6+KDIF))B=B-2.4
CREATES PARTIAL BEAM IF NECESSARY. (I.E. THERE'S A REST INVOLVED.)
RN(8+KDIF)=A
RN(9+KDIF)=B
514 J=J+1
A=VX(J)
N=A
C SO ITEMS NEED NOT BE IN RIGHT ORDER.
IF(MOD(N,100).GT.IRHY)A=0
IF(A.NE.0)GO TO 505
IF(J.LT.50)GO TO 514
C SOMETIMES A SLASH IS SEEN AS A 0 (WHEN PRECEDED BY SPACE).
614 IF(INP(72).NE.ISTAR)GO TO 552
714 IF(INVT)RETURN
INVT=IS
CALL NEWR
IS=INVT
RETURN
552 CALL BMREAD
C TO READ MORE THAN 2 LINES.
GO TO 25
END
SUBROUTINE BMREAD
COMMON /ALF/INP(72) /IDEV/IDEV
CALL TYPE
IF(IDEV.EQ.5)CALL INPOUT
C WRITES OUT INPUT LINE.
1 CALL LNEND
CALL LULOOP
C CHANGE LOWER CASE TO UPPER.
END
FUNCTION NREST(K)
COUNTS REST FROM START OF LINE UP TO ITEM K-1 (K IS A NOTE)
COMMON /SCM/V(1)
NREST=0
DO 1 J=1,K-1
1 IF(V(J))NREST=NREST+1
END